home *** CD-ROM | disk | FTP | other *** search
/ FM Towns: Free Software Collection 10 / FM Towns Free Software Collection 10.iso / ms_dos / lib / happysrc / pccalusr.c < prev    next >
Text File  |  1994-10-02  |  9KB  |  229 lines
  1. /*********************************************************************
  2.  *
  3.  *   *** HAPPy Pascal Compiler ***
  4.  *      ユーザ定義の手続き､関数の呼出処理
  5.  *
  6.  *    void calluser(Set fsys, ctp *fcp) ;
  7.  *
  8.  *             Copyright (c) H.Asano 1992,1994.
  9.  *
  10.  *********************************************************************/
  11.  
  12. #define EXTERN extern
  13. #include "pascomp.h"
  14. #include "pcpcd.h"
  15.  
  16. extern void expression(Set) ;
  17. extern void selector(Set,ctp*) ;
  18. extern ctp  *searchid(Set)  ;
  19. extern Set  *mkset(Set*,int,...) ;
  20. extern Set  *orset(Set*,Set*);
  21. extern void pcerr(int,char*) ;
  22. extern void insymbol(void)   ;
  23. extern boolean compatible(stp*,stp*) ;
  24. extern boolean assigncompati(stp*,stp*) ;
  25. extern int align(stp*,int)   ;
  26. extern void gen0(enum pcdmnc) ;
  27. extern void genp(enum pcdmnc,int) ;
  28. extern void gen2t(enum pcdmnc, stp*,int,int);
  29. extern void gencupejp(enum pcdmnc,int,int) ;
  30. extern void genjump(enum pcdmnc,int) ;
  31. extern void load(void)        ;
  32. extern void loadaddress(void) ;
  33. extern void checkbounds(stp*,int) ;
  34. extern void skip(Set) ;
  35.  
  36. static int  pfparm(ctp *) ;
  37. static int actualparm(Set,ctp*) ;
  38. static boolean congruity(ctp*,ctp*) ;
  39.  
  40. /**********************************************/
  41. /* calluser() : ユーザ定義の手続き･関数の呼出 */
  42. /**********************************************/
  43. void calluser(Set fsys,ctp *fcp)
  44. {
  45.   ctp *nxt ;
  46.   enum idkind lkind ;
  47.   int locpar = 0;                       /* スタックにのせる引数のサイズ*/
  48.   boolean err126 = false ;
  49.  
  50.      lkind = fcp->n.pf.sd.d.pfkind ;    /* actual / formal            */
  51.  
  52.      if(lkind == actual) {              /* 実手続き､実関数の呼出の時  */
  53.       genp(iMST,level-fcp->n.pf.sd.d.pflev) ; /* mst 命令 を 生成     */
  54.       nxt = fcp->next ;
  55.      }
  56.      else {                             /* 仮手続き､仮関数の呼出の時  */
  57.       gen2t(iLOD,nilptr,level-fcp->n.pf.sd.d.pflev,
  58.                 fcp->n.pf.sd.d.af.f.levadr) ; /* loda  mark           */
  59.       gen0(iMSI) ;                            /*  msi                 */
  60.       nxt = fcp->n.pf.sd.d.af.f.prm ;
  61.      }
  62.  
  63.      if(sy ==lparent) {
  64.       do {
  65.        insymbol() ;
  66.        if(!nxt && !err126) {
  67.         pcerr(126,"") ;                 /* 実引数と仮引数の数が違う   */
  68.         err126 = true ;
  69.        }
  70.        if(nxt &&
  71.         ((nxt->klass==proc) || (nxt->klass==func)))
  72.         locpar += pfparm(nxt) ;         /* 関数引数､手続き引数        */
  73.        else                             /* 値引数､変数引数            */
  74.         locpar += actualparm(fsys,nxt) ;
  75.        locpar = align(parmptr,locpar) ;
  76.  
  77.        if(nxt) nxt = nxt->next ;        /* 次の引数                   */
  78.  
  79.       } while(sy==comma) ;
  80.  
  81.       if(sy == rparent) insymbol() ;
  82.       else pcerr(4,"") ;                /* ) がない                   */
  83.      }
  84.  
  85.      if(nxt && !err126) pcerr(126,"") ; /* 実引数と仮引数の数が違う   */
  86.  
  87.  
  88.      if(lkind == actual)                /* 実手続き､実関数の呼出の時  */
  89.       gencupejp(iCUP,locpar,fcp->n.pf.sd.d.af.a.pfname);/* cup命令生成*/
  90.      else {                             /* 仮手続き､仮関数の呼出の時  */
  91.       gen2t(iLOD,nilptr,level-fcp->n.pf.sd.d.pflev,
  92.                          fcp->n.pf.sd.d.af.f.adradr) ; /*loda 実行adr */
  93.       genp(iCUI,locpar) ;               /* cui命令生成                */
  94.      }
  95.  
  96.      gattr.typtr = fcp->idtype ;        /* 手続き･関数の型            */
  97. }
  98.  
  99. /********************************************/
  100. /* actualparm() : 値､変数パラメータ処理     */
  101. /********************************************/
  102. static int actualparm(Set fsys,ctp *fnxt)
  103. {
  104.   stp *lsp ;
  105.   ctp *lcp ;
  106.   int locpar = 0 ;
  107.   Set ws,ws2 ;
  108.  
  109.      mkset(&ws,comma,rparent,-1) ;
  110.      mkset(&ws2,vars,field,-1)   ;
  111.      if(fnxt) {                         /* 引数がある                 */
  112.  
  113.       lsp = fnxt->idtype ;
  114.       if(fnxt->n.v.vkind == actual) {   /* 値引数の時                 */
  115.        expression(ws) ;                 /* 式の処理                   */
  116.        if(!assigncompati(lsp,gattr.typtr)) /* 代入可能性チェック      */
  117.         pcerr(155,"") ;                 /* 代入不可能                 */
  118.        if(lsp->form <= power) {         /* スカラ､範囲型､ポインタ､集合*/
  119.         load() ;                        /*   load命令                 */
  120.         if(lsp->form == power)
  121.          checkbounds(lsp,8) ;           /*  集合値の範囲チェック      */
  122.         else if(lsp->form <= subrange)
  123.          checkbounds(lsp,7) ;           /*  順序型の範囲チェック      */
  124.         if((lsp == realptr) &&          /*   宣言がreal型で           */
  125.           compatible(gattr.typtr,intptr)) {  /* 実引数がintegerの時   */
  126.          gen0(iFLT) ;                   /*    flt命令生成             */
  127.          gattr.typtr = realptr ;
  128.         }
  129.         locpar = lsp->size ;            /* スタックに積む引数サイズ計算*/
  130.        }
  131.        else {                           /* 配列､レコード              */
  132.         loadaddress() ;                 /*   loadaddress命令          */
  133.         locpar = parmsize ;             /*   アドレス分のサイズ       */
  134.        }
  135.       }
  136.       else  {                           /* 変数引数の時               */
  137.        if(sy == ident) {
  138.         lcp = searchid(ws2) ;           /* 変数､フィールド名から探す  */
  139.         insymbol() ;
  140.         selector(ws,lcp) ;
  141.         if(lsp != gattr.typtr)          /*   型が違う                 */
  142.          pcerr(142,"") ;                /*   仮引数と実引数の型不一致 */
  143.         if((gattr.typtr->form == files) /* 変数引数のファイルの時は   */
  144.          &&(gattr.access == indrct))    /*     自前でloda する        */
  145.          gen2t(iLOD,nilptr,level-gattr.vlevel,gattr.dplmt) ;
  146.         else loadaddress() ;            /*   loadaddress命令          */
  147.         locpar = parmsize ;             /*   アドレス分のサイズ       */
  148.        }
  149.        else {
  150.         pcerr(6,"") ;                   /* 不当な記号が現れた         */
  151.         skip(ws)    ;
  152.        }
  153.       }
  154.      }
  155.      else expression(ws) ;            /* 仮引数がない時､とりあえず
  156.                                         実引数を式として処理しておく*/
  157.      return(locpar) ;
  158. }
  159.  
  160. /**************************************************/
  161. /* pfparm() : 手続き名､関数名実パラメータ処理     */
  162. /**************************************************/
  163. static int pfparm(ctp *fnxt)            /* fnxt:仮引数                */
  164. {
  165.   ctp *lcp , *lcp1;
  166.   Set ws;
  167.  
  168.      mkset(&ws, func,proc, -1);
  169.      lcp = searchid(ws) ;               /* 手続き名､関数名から探す    */
  170.      if(lcp->klass != fnxt->klass)      /* 引数の種類が違う           */
  171.       pcerr(142,"") ;                   /* 仮引数と実引数の型が不一致 */
  172.      else
  173.       if(lcp->n.pf.pfdeckind == standard)
  174.        (lcp->klass==proc) ? pcerr(174,lcp->name) : pcerr(175,lcp->name);
  175.                                         /* 標準手続き･関数は実引数駄目*/
  176.       else {
  177.        lcp1 = (lcp->n.pf.sd.d.pfkind==actual)
  178.                  ? lcp->next : lcp->n.pf.sd.d.af.f.prm ;
  179.        if(!congruity(lcp1,fnxt->n.pf.sd.d.af.f.prm))
  180.         pcerr(127,lcp->name);           /* 同形でない                 */
  181.        else if(lcp->klass == func)
  182.         if(lcp->idtype != fnxt->idtype)
  183.          pcerr(173,lcp->name) ;         /* 関数の結果の型が違う       */
  184.       }
  185.  
  186.      if(lcp->n.pf.sd.d.pfkind==actual) {/* 実引数の時                 */
  187.       genp(iBAS,level - lcp->n.pf.sd.d.pflev) ;/* baseアドレスを求める*/
  188.       genjump(iLAP,lcp->n.pf.sd.d.af.a.pfname);/*実行アドレス         */
  189.      }
  190.      else {                             /* 仮引数の時                 */
  191.       gen2t(iLOD,nilptr,level - lcp->n.pf.sd.d.pflev,
  192.                          lcp->n.pf.sd.d.af.f.levadr) ; /*loda 定義水準*/
  193.       gen2t(iLOD,nilptr,level - lcp->n.pf.sd.d.pflev,
  194.                          lcp->n.pf.sd.d.af.f.adradr) ; /*loda 実行adr */
  195.      }
  196.  
  197.      insymbol() ;
  198.      return(2)  ; /* 暫定  アドレスサイズ×2を返せば良い */
  199. }
  200.  
  201. /******************************************/
  202. /* congruity() : パラメータの同形チェック */
  203. /******************************************/
  204. static boolean congruity(ctp *fcp1,ctp *fcp2)
  205. {
  206.      while(fcp1 && fcp2) {              /* 2つとも引数があれば        */
  207.       if(fcp1->klass != fcp2->klass)    /* 引数の種類が違う           */
  208.        return(false) ;
  209.       if(fcp1->klass == vars) {         /* 値､変数の時                */
  210.        if(fcp1->linkno != fcp2->linkno) /* 名前並びの数が違う         */
  211.         return(false) ;
  212.        if(fcp1->n.v.vkind != fcp2->n.v.vkind) /* 値､変数の種類が違う  */
  213.         return(false) ;
  214.        if(fcp1->idtype != fcp2->idtype) /* 型が違う                   */
  215.         return(false) ;
  216.       }
  217.       else {
  218.        if(fcp1->klass == func)          /* 関数引数の時               */
  219.         if(fcp1->idtype != fcp2->idtype)/*  関数の結果型が違う        */
  220.          return(false);
  221.        if(!congruity(fcp1->n.pf.sd.d.af.f.prm, fcp2->n.pf.sd.d.af.f.prm))               return(false) ;            /* それぞれの仮引数についてチェック*/
  222.       }
  223.       fcp1 = fcp1->next ;
  224.       fcp2 = fcp2->next ;
  225.      }
  226.      return((!fcp1) && (!fcp2))          ;/* 両方とも数が同じならOK
  227.                                              数が違えば          NG   */
  228. }
  229.